module FreeVarsP where
import Utils
import DataSTG
import LanguageSTG
-- import IOExts ( unsafePerformIO )
-- (unsafePerformIO.print.setShow.setFromList.aDomain) prog `seq`


freeVarsP :: STGProgram -> STGProgram
freeVarsP prog =  aMapLig (freeVarsLf (setFromList (aDomain prog))) prog

freeVarsLf :: Set Var -> LambdF -> LambdF
freeVarsLf setNo (fs, up, ls, e) = (fvs', up, ls, e')
    where (fvs, e') = freeVarsE setNo e
          fvs' = setSubtraction fvs (setFromList ls)

freeVarsE :: Set Var ->STGExpr -> (Set Var, STGExpr)

freeVarsE setNo (ELet isRec binds e) = 
              let (fvsbinds, binds') = freeVarsBinds setNo binds
                  (fvse, e') = freeVarsE setNo' e
                  setNo0 = setFromList (aDomain binds)
                  setNo' = setSubtraction setNo setNo0
                  fvs = setUnion fvse fvsbinds
                  fvs' = setSubtraction fvs setNo0
              in (fvs', ELet isRec binds' e') --Expresion Let

freeVarsE setNo (ELambObs vars e _) = freeVarsE setNo (ELamb vars e)
freeVarsE setNo (ELamb vars e) = 
              let (fvse, e') = freeVarsE setNo' e
                  setNo0 = setFromList vars
                  setNo' = setSubtraction setNo setNo0
                  fvs' = setSubtraction fvse setNo0
              in (fvs', ELamb vars e') --Expresion Lamb

freeVarsE setNo (ECase e alts) = 
              let (fvs, e') = freeVarsE setNo e
                  (fvsal, alts') = freeVarsAlts setNo alts
                  fvs' = setUnion fvs fvsal
              in (fvs' ,ECase e' alts')       --Expresion Case

-- freeVarsE setNo e@(EAp (EVar f) ats) = 
--               let fvs = freeVarsAts setNo ats
--                   fvs' | setElementOf f setNo = fvs
--                        | otherwise = setPut fvs f 
--               in (fvs', e)            --Aplicaciones
-- 
freeVarsE setNo (EAp e ats) = 
              let (fvs, e') = freeVarsE setNo e
                  fvsats = freeVarsAts setNo ats
                  fvs' = setUnion fvs fvsats
              in (fvs', (EAp e' ats))            --Aplicaciones

freeVarsE setNo e@(EVar f) = 
              let fvs | setElementOf f setNo = setEmpty
                      | otherwise = setSingleton f 
              in (fvs, e)            --Variable

freeVarsE setNo e@(EVarObs f _) = 
              let fvs | setElementOf f setNo = setEmpty
                      | otherwise = setSingleton f 
              in (fvs, e)            --Variable observable

freeVarsE setNo e@(EVarObsI f _) = 
              let fvs | setElementOf f setNo = setEmpty
                      | otherwise = setSingleton f 
              in (fvs, e)            --Variable observable

freeVarsE setNo e@(EConstr con ats) = 
              let fvs = freeVarsAts [] ats
              in (fvs, e)                     --Constructores

freeVarsE setNo e@(EOp po ats) = 
              let fvs = freeVarsAts setNo ats
              in (fvs, e)                     --Operaciones primitivas
                            
freeVarsE setNo e@(Lit n) = (setEmpty, e)     --Literales

freeVarsAts :: Set Var -> Atoms -> Set Var --El primer conjunto es a eliminar
freeVarsAts setNo atms = setSubtraction (setFromList (varsAts atms)) setNo

varsAts :: Atoms -> Vars
varsAts [] = []
varsAts ((AVar v):atms) = v : varsAts atms
varsAts (_:atms) = varsAts atms

freeVarsBinds :: Set Var -> Binds -> (Set Var, Binds)
freeVarsBinds setNo [] = (setEmpty, [])
freeVarsBinds setNo (b1:binds) = (fvs', b1':binds')
       where setNo0 = setFromList (aDomain binds)
             (fvs, b1') = freeVarsBind setNo b1
             (fvsbinds, binds') = freeVarsBinds setNo binds
             fvs1 = setUnion fvs fvsbinds
             fvs' = setSubtraction fvs1 setNo0

freeVarsBind :: Set Var -> (Var, LambdF) -> (Set Var, (Var, LambdF))
freeVarsBind setNo (var, lf) = (fvs', (var, lf'))
       where setNo' = setEliminate setNo var
             lf' = freeVarsLf setNo' lf
             fvs = freeVars lf'
             fvs'= setEliminate fvs var

freeVarsAlts :: Set Var -> Alts -> (Set Var, Alts)
freeVarsAlts setNo (PriAlt palts []) =
                let (fvs', palts') = mapAccumList (freeVarsPalt setNo) palts
                in (fvs', (PriAlt palts' []))
freeVarsAlts setNo (PriAlt palts [def]) =
                let (fvs1, palts') = mapAccumList (freeVarsPalt setNo) palts
                    (fvs2, def') = freeVarsDefault setNo def
                    fvs' = setUnion fvs1 fvs2
                in (fvs', (PriAlt palts' [def']))
freeVarsAlts setNo (AlgAlt aalts []) =
                let (fvs', aalts') = mapAccumList (freeVarsAalt setNo) aalts
                in (fvs', (AlgAlt aalts' []))
freeVarsAlts setNo (AlgAlt aalts [def]) =
                let (fvs1, aalts') = mapAccumList (freeVarsAalt setNo) aalts
                    (fvs2, def') = freeVarsDefault setNo def
                    fvs' = setUnion fvs1 fvs2
                in (fvs', (AlgAlt aalts' [def']))

freeVarsPalt :: Set Var -> Palt -> (Set Var, Palt)
freeVarsPalt setNo (li, e) = (fvs', (li, e'))
      where (fvs', e') = freeVarsE setNo e

--No se si estan bien
freeVarsAalt :: Set Var -> Aalt -> (Set Var, Aalt)
freeVarsAalt setNo (cons, vars, e) = (fvs', (cons, vars, e'))
      where setNo0 = setFromList vars
            setNo' = setSubtraction setNo setNo0
            (fvs, e') = freeVarsE setNo' e
            fvs' = setSubtraction fvs setNo0
            
freeVarsDefault :: Set Var -> Default -> (Set Var, Default)
freeVarsDefault setNo (DefV v e) = (fvs', DefV v e')
      where setNo' = setEliminate setNo v
            (fvs, e') = freeVarsE setNo' e
            fvs' = setEliminate fvs v
freeVarsDefault setNo (Def e) = (fvs', Def e')
      where (fvs', e') = freeVarsE setNo e
